home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / basic / pbc_bas.exe / OBJSCAN.BAS < prev    next >
Encoding:
BASIC Source File  |  1993-01-01  |  5.2 KB  |  124 lines
  1. '   +----------------------------------------------------------------------+
  2. '   |                                                                      |
  3. '   |        PBClone  Copyright (c) 1990-1993  Thomas G. Hanlin III        |
  4. '   |                                                                      |
  5. '   +----------------------------------------------------------------------+
  6.  
  7.    DECLARE FUNCTION IsLower% (Ch$)
  8.    DECLARE SUB FClose1 (BYVAL FileHandle%)
  9.    DECLARE SUB FOpen1 (FileName$, BYVAL ReadWrite%, BYVAL Sharing%, FileHandle%, ErrCode%)
  10.    DECLARE SUB FSetOfs (BYVAL FileHandle%, Offset&)
  11.    DECLARE SUB SFRead (BYVAL FileHandle%, St$, BytesRead%, ErrCode%)
  12.  
  13.    DECLARE FUNCTION AnyLowerCase% (St$)
  14.  
  15. SUB ObjScan (ObjFile$, ModName$, Routine$(), External$(), ErrCode%)
  16.    St$ = ObjFile$
  17.    IF INSTR(St$, ".") = 0 THEN St$ = St$ + ".OBJ"
  18.    FOpen1 St$, 0, 2, Handle%, ErrCode%
  19.    IF ErrCode% = 0 THEN
  20.       RoutinePtr% = LBOUND(Routine$)
  21.       ExternPtr% = LBOUND(External$)
  22.       GOSUB ScanObject
  23.       FClose1 Handle%
  24.    END IF
  25.  
  26.    EXIT SUB
  27.  
  28. ScanObject:
  29.    Done% = 0
  30.    DO
  31.       St$ = SPACE$(3)
  32.       SFRead Handle%, St$, br%, ErrCode%
  33.       IF ErrCode% THEN EXIT DO
  34.       ObjTyp% = ASC(LEFT$(St$, 1))                         ' type of record
  35.       ObjLen& = CVL(MID$(St$, 2) + STRING$(2, 0))          ' length of record
  36.       IF ObjTyp% = &H80 THEN                   ' module name -----------------
  37.          St$ = SPACE$(ObjLen&)
  38.          SFRead Handle%, St$, br%, ErrCode%                ' get entire record
  39.          IF ErrCode% THEN EXIT DO
  40.          ModName$ = MID$(St$, 2, ASC(LEFT$(St$, 1)))       ' get module name
  41.          tmp% = INSTR(ModName$, ":")                       ' remove misc junk
  42.          IF tmp% THEN ModName$ = MID$(ModName$, tmp% + 1)
  43.          DO
  44.             tmp% = INSTR(ModName$, "\")
  45.             IF tmp% THEN ModName$ = MID$(ModName$, tmp% + 1)
  46.          LOOP WHILE tmp%
  47.          DO
  48.             tmp% = INSTR(ModName$, "/")
  49.             IF tmp% THEN ModName$ = MID$(ModName$, tmp% + 1)
  50.          LOOP WHILE tmp%
  51.          tmp% = INSTR(ModName$, ".")
  52.          IF tmp% THEN ModName$ = LEFT$(ModName$, tmp% - 1)
  53.       ELSEIF ObjTyp% = &H8C THEN               ' external definitions --------
  54.          St$ = SPACE$(ObjLen&)
  55.          SFRead Handle%, St$, br%, ErrCode%                ' get entire record
  56.          IF ErrCode% THEN EXIT DO
  57.          St$ = LEFT$(St$, LEN(St$) - 1)                    ' remove checksum
  58.          DO
  59.             IF ExternPtr% > UBOUND(External$) THEN         ' if array overflow
  60.                ErrCode% = -2
  61.                EXIT DO
  62.             END IF
  63.             tmp% = ASC(LEFT$(St$, 1))                      ' routine name length
  64.             Pub$ = MID$(St$, 2, tmp%)                      ' routine name
  65.             St$ = MID$(St$, 2 + tmp% + 1)
  66.                                                            ' skip BASIC internal names
  67.             IF INSTR(Pub$, "$") = 0 AND LEFT$(Pub$, 1) <> "_" AND NOT AnyLowerCase(Pub$) AND RIGHT$(Pub$, 2) <> "QQ" THEN
  68.                IF Pub$ <> "STRINGADDRESS" AND Pub$ <> "STRINGASSIGN" AND Pub$ <> "STRINGLENGTH" AND Pub$ <> "STRINGRELEASE" AND Pub$ <> "SETUEVENT" THEN
  69.                   IF Pub$ <> "GETCONTAINER" AND Pub$ <> "GETPROPERTY" AND Pub$ <> "INVOKEEVENT" AND Pub$ <> "INVOKEMETHOD" AND Pub$ <> "SETPROPERTY" THEN
  70.                      External$(ExternPtr%) = Pub$          ' store routine name
  71.                      ExternPtr% = ExternPtr% + 1           ' update name ptr
  72.                   END IF
  73.                END IF
  74.             END IF
  75.          LOOP WHILE LEN(St$)
  76.       ELSEIF ObjTyp% = &H90 THEN               ' public definitions ----------
  77.          St$ = SPACE$(ObjLen&)
  78.          SFRead Handle%, St$, br%, ErrCode%                ' get entire record
  79.          IF ErrCode THEN EXIT DO
  80.          St$ = LEFT$(St$, LEN(St$) - 1)                    ' remove checksum
  81.          IF LEFT$(St$, 2) = STRING$(2, 0) THEN             ' remove header
  82.             St$ = MID$(St$, 5)
  83.          ELSE
  84.             St$ = MID$(St$, 3)
  85.          END IF
  86.          DO
  87.             IF RoutinePtr% > UBOUND(Routine$) THEN         ' if array overflow
  88.                ErrCode% = -2
  89.                EXIT DO
  90.             END IF
  91.             tmp% = ASC(LEFT$(St$, 1))                      ' routine name len
  92.             Routine$(RoutinePtr%) = MID$(St$, 2, tmp%)     ' get a routine name
  93.             RoutinePtr% = RoutinePtr% + 1                  ' update name ptr
  94.             St$ = MID$(St$, 2 + tmp% + 3)                  ' wipe from rec info
  95.          LOOP WHILE LEN(St$)
  96.       ELSEIF ObjTyp% = &H8A THEN               ' end of module ---------------
  97.          Done% = -1
  98.       ELSE                                     ' skip anything else ----------
  99.          FSetOfs Handle%, ObjLen&
  100.       END IF
  101.    LOOP UNTIL ErrCode% OR Done%
  102.    IF ErrCode% = 0 THEN
  103.       IF ExternPtr% <= UBOUND(External$) THEN
  104.          External$(ExternPtr%) = ""
  105.       END IF
  106.       IF RoutinePtr% <= UBOUND(Routine$) THEN
  107.          Routine$(RoutinePtr%) = ""
  108.       END IF
  109.    END IF
  110.    RETURN
  111. END SUB
  112.  
  113.  
  114.  
  115. FUNCTION AnyLowerCase% (St$)
  116.    FOR x% = 1 TO LEN(St$)
  117.       IF IsLower%(MID$(St$, x%, 1)) THEN
  118.          lc% = -1
  119.          EXIT FOR
  120.       END IF
  121.    NEXT
  122.    AnyLowerCase% = lc%
  123. END FUNCTION
  124.